home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / UTILITIE / CONVERSI / 0825C.ZIP / BINHEX.V30 < prev    next >
Text File  |  1980-01-01  |  19KB  |  461 lines
  1. 10 'BinHex version 3.0.0 - By William B. Davis, Jr {CIS 71505,410}
  2. 20 'with modifications by     Bob VanBurkleo {CIS 74435,1373}
  3. 30 'using subroutines by:
  4. 40 '     Dennis Brothers of Brothers Associates {CIS 70065,172}
  5. 50 '     Ronald H. Nicholson, Jr {CIS 71505,410}
  6. 60 'Permission is hereby granted for personal, non-commercial reproduction
  7. 70 'and use of this program, provided that this notice is included.
  8. 100 CLEAR,24000
  9. 110 CLEAR:DEFINT P:DIM PARAMLIST%(39),RECT%(5),BACKPATTERN%(4),GETFILEINFOCODE%(25)
  10. 120 DIM SETFILEINFOCODE%(25),P(89),DBUF%(256),VBUF%(266)
  11. 130 X255%=255:LFR=0:LFD=0:RFN=0
  12. 140 A=0:BOX=0:BX=0:BY=0:TRUE=-1:FALSE=0:CHOICE=0:CKSUM%=0:COUNT=0:E=0
  13. 150 FILE=0:FILEINFO!=0:FL=0:LF=0:FP!=0:I=0:LP=0:P=0:PARAM!=0:TR=0:PX=0:PY=0
  14. 160 R=0:RC=0:RF=0:RN=0:RW=0:RX=0:S=0:SETFILEINFO!=0:GETFILEINFO!=0:X=0:X9=0:Y=0:XX%=0
  15. 170 A$="":BF$="":D$="":E$="":DD$="":F$="":FT$="":HF$="":HX$="":RET$="":S$="":TEXT$="":FILE.EXISTS=0
  16. 180 TYPEAPPL$="":X$="":XX$=""
  17. 1000 WIDTH "SCRN:",255
  18. 1010 WHILE TRUE
  19. 1020    GOSUB 8000:CALL SHOWCURSOR
  20. 1030    RECT%(0)=2:RECT%(1)=10:RECT%(2)=275:RECT%(3)=475:GOSUB 7100
  21. 1040    RECT%(0)=5:RECT%(1)=13:RECT%(2)=272:RECT%(3)=472:GOSUB 7200
  22. 1050    CALL TEXTFONT(0):CALL TEXTSIZE(12)
  23. 1060    CALL TEXTMODE(1):CALL TEXTFACE(8)
  24. 1070    CALL MOVETO (45,20)
  25. 1080    PRINT"BinHex -- Hex to binary/Binary to hex file conversion"
  26. 1090    CALL MOVETO(140,40):CALL TEXTFACE(0)
  27. 1100    CALL TEXTFONT(1):CALL TEXTSIZE(9)
  28. 1110    PRINT"          Version 3.0.0 - Data & Resource Files";
  29. 1120    CALL MOVETO(35,260)
  30. 1130    PRINT"Copyright ";CHR$(169);"1984 by Calypso! Software ";
  31. 1140    PRINT"- May be reproduced for non-commercial use only.";
  32. 1150    CALL TEXTFONT(0):CALL TEXTSIZE(12)
  33. 1160    CALL MOVETO (120,68):PRINT"Click on the desired conversion method:";
  34. 1170    RESTORE 1200:GOSUB 6000
  35. 1180    ON CHOICE GOSUB 3000,2000,1500,1600
  36. 1185 GOTO 110
  37. 1190 WEND:STOP
  38. 1200 DATA 75,90,"Application document --> Upload format document"
  39. 1210 DATA 75,130,"Upload format document --> Application document"
  40. 1220 DATA 75,170,"Quit BinHex and return to the Macintosh Desktop"
  41. 1230 DATA 75,210,"Quit BinHex and return to Microsoft BASIC"
  42. 1240 DATA -1,-1,"Dummy end of list"
  43. 1500 GOSUB 8000
  44. 1510 RECT%(0)=100:RECT%(1)=100:RECT%(2)=150:RECT%(3)=400:GOSUB 7100
  45. 1520 RECT%(0)=103:RECT%(1)=103:RECT%(2)=147:RECT%(3)=397:GOSUB 7200
  46. 1530 CALL MOVETO(120,130):PRINT"Returning to Macintosh DeskTop....";
  47. 1540 SYSTEM
  48. 1600 CLS:CALL TEXTFONT(1):CALL TEXTSIZE(12)
  49. 1610 CALL TEXTMODE(0):CALL TEXTFACE(0)
  50. 1620 PRINT"Entering MS-BASIC Command mode....":END
  51. 1630 '--------------------------------------------------------
  52. 1640 '"             Hex ---> Binary conversion procedure
  53. 1650 '--------------------------------------------------------
  54. 2000 CHOICE=1
  55. 2010 WHILE CHOICE=1:GOSUB 8000:ON ERROR GOTO 0
  56. 2020 CALL TEXTMODE(1):CALL TEXTFACE(8)
  57. 2030 RECT%(0)=32:RECT%(1)=2:RECT%(2)=200:RECT%(3)=480:GOSUB 7100
  58. 2040 RECT%(0)=35:RECT%(1)=5:RECT%(2)=197:RECT%(3)=477:GOSUB 7200
  59. 2050 CALL MOVETO(15,52)
  60. 2060 PRINT "Convert Upload document (hex) to an Application document";
  61. 2070 CALL TEXTFACE(32):CALL MOVETO (15,73)
  62. 2080 PRINT "Enter name of Upload Document to convert FROM (Press RETURN to cancel):";
  63. 2090 CALL MOVETO(15,153)
  64. 2100 PRINT "Enter name of Application Document to CREATE (RETURN key skips back):";
  65. 2110 RECT%(0)=80:RECT%(1)=15:RECT%(2)=105:RECT%(3)=450:GOSUB 7000
  66. 2120 RECT%(0)=160:RECT%(1)=15:RECT%(2)=185:RECT%(3)=450:GOSUB 7000
  67. 2130 BX=20:BY=95:GOSUB 7500:HF$=RET$:IF HF$="" THEN RETURN
  68. 2140 FILE.EXISTS=TRUE
  69. 2150 ON ERROR GOTO 3600:OPEN"I",1,HF$
  70. 2160 CLOSE:IF NOT FILE.EXISTS THEN 2000
  71. 2170 BX=20:BY=175:GOSUB 7500:BF$=RET$:IF BF$="" THEN 2000
  72. 2180 OPEN"I",1,HF$,1:OPEN"O",2,BF$
  73. 2185 F$=HF$:GOSUB 4580:GOSUB 4000:LF=LFD
  74. 2190 '       Read in lines from file & ignore anything until the 
  75. 2200 '       Type/Creator header information is encountered.
  76. 2210 CKSUM%=0
  77. 2220 LINE INPUT #1,D$:'"   Prime the pump....
  78. 2230 WHILE LEFT$(D$,1)<>"#" AND NOT EOF(1)
  79. 2240    LINE INPUT #1,D$
  80. 2250 WEND
  81. 2260 '     if we reach this point (1) we have found the header, of the form
  82. 2270 '     #TYPECRTR where TYPE is 4 byte type code & CRTR is 4 byte 
  83. 2280 '     creator code; or (2) we have reached EOF of hex file.
  84. 2290 WHILE NOT EOF(1)
  85. 2300    TYPEAPPL$=MID$(D$,2,8)
  86. 2310    GOSUB 8000
  87. 2320    RECT%(0)=50:RECT%(1)=100:RECT%(2)=200:RECT%(3)=400
  88. 2330    CALL PENNORMAL:GOSUB 7000
  89. 2340    RECT%(0)=53:RECT%(1)=103:RECT%(2)=197:RECT%(3)=397
  90. 2350    CALL PENSIZE(2,2):GOSUB 7000:CALL PENNORMAL
  91. 2360    CALL MOVETO(110,80):CALL TEXTFACE(0):CALL TEXTMODE(1)
  92. 2370    PRINT "TYPE of new file is................:";MID$(TYPEAPPL$,1,4)
  93. 2380    CALL MOVETO(110,95)
  94. 2390    PRINT "CREATOR of new file is..........:";MID$(TYPEAPPL$,5,4)
  95. 2400    CALL MOVETO(110,110)
  96. 2410    PRINT USING "Length of new file will be approx : ###.##K";(LOF(1)/2)/1024;
  97. 2420    CALL MOVETO(110,175)
  98. 2430    PRINT "Conversion in process - Please stand by...."
  99. 2440    CALL TEXTMODE(0)
  100. 2450    F$=BF$:GOSUB 4660:GOSUB 4200:'"   Set type and creator of file
  101. 2460    LINE INPUT #1,D$
  102. 2470    IF LEFT$(D$,12)="***DATA FORK" THEN LINE INPUT #1,D$:CALL MOVETO (110,140):PRINT BF$;": a Data File"
  103. 2475 IF LEFT$(D$,11)="***RESOURCE" THEN CALL MOVETO(110,140):PRINT BF$;": a Resource File":GOSUB 21000:GOTO 2540
  104. 2480    WHILE NOT EOF(1)  AND LEFT$(D$,14)<>"***END OF DATA" 
  105. 2490            GOSUB 2800:'  Convert string to binary
  106. 2500            LINE INPUT #1,D$
  107. 2510    WEND
  108. 2520    IF NOT EOF(1) THEN LINE INPUT #1,D$:'get checksum if available
  109. 2525 GOTO 2540
  110. 2530 WEND
  111. 2540 CLOSE:GOSUB 8000
  112. 2550 RECT%(0)=30:RECT%(1)=80:RECT%(2)=220:RECT%(3)=410:GOSUB 7100
  113. 2560 RECT%(0)=33:RECT%(1)=83:RECT%(2)=217:RECT%(3)=407:GOSUB 7200
  114. 2570 CALL MOVETO (100,55):CALL TEXTMODE(1)
  115. 2580 PRINT "Conversion of upload format document to";
  116. 2590 CALL MOVETO(100,70)
  117. 2600 PRINT "application document has been completed!";
  118. 2610 CALL MOVETO(140,100)
  119. 2620 IF LEFT$(D$,12)="***CHECKSUM:" THEN PRINT "Checksum in file: ";MID$(D$,13,2);
  120. 2630 IF LEFT$(D$,12)<>"***CHECKSUM:" THEN PRINT "No checksum present in file...";
  121. 2640 XX$=HEX$(CKSUM%):IF LEN(XX$)<2 THEN XX$="0"+XX$
  122. 2650 CALL MOVETO (140,115):PRINT "Calculated Checksum: ";XX$;
  123. 2660 BEEP:RESTORE 2690:GOSUB 6000:CALL TEXTMODE(0)
  124. 2670 WEND:' of the WHILE CHOICE=1
  125. 2680 RETURN:' if CHOICE=2
  126. 2690 DATA 130,155,"Convert another upload document"
  127. 2700 DATA 130,180,"Return to Main Conversion menu"
  128. 2710 DATA -1,-1,"dummy end of list"
  129. 2720 '----- Loop to break down input line into byte-pairs & convert -----
  130. 2800 FOR I=1 TO LEN(D$) STEP 2
  131. 2810    XX%=VAL("&H"+MID$(D$,I,2)):CKSUM%=(CKSUM%+XX%) AND 255
  132. 2820    PRINT #2,CHR$(XX%);
  133. 2830 NEXT I:RETURN
  134. 2840 '-------------------------------------------------------
  135. 2850 '               Binary ---> Hex conversion procedure
  136. 2860 '-------------------------------------------------------
  137. 3000 CHOICE=1
  138. 3010 WHILE CHOICE=1:GOSUB 8000
  139. 3020 ON ERROR GOTO 0:CALL TEXTMODE(1):CALL TEXTFACE(8)
  140. 3030 RECT%(0)=32:RECT%(1)=2:RECT%(2)=200:RECT%(3)=480:GOSUB 7100
  141. 3040 RECT%(0)=35:RECT%(1)=5:RECT%(2)=197:RECT%(3)=477:GOSUB 7200
  142. 3050 CALL MOVETO(15,52)
  143. 3060 PRINT "Convert Application document to an Upload document (hex)";
  144. 3070 CALL TEXTFACE(32):CALL MOVETO (15,73)
  145. 3080 PRINT "Enter name of Application Document to convert FROM (Press RETURN to cancel):";
  146. 3090 CALL MOVETO(15,153)
  147. 3100 PRINT "Enter name of Upload Document to CREATE (RETURN key skips back):";
  148. 3110 RECT%(0)=80:RECT%(1)=15:RECT%(2)=105:RECT%(3)=450:GOSUB 7000
  149. 3120 RECT%(0)=160:RECT%(1)=15:RECT%(2)=185:RECT%(3)=450:GOSUB 7000
  150. 3130 BX=20:BY=95:GOSUB 7500:BF$=RET$:IF BF$="" THEN RETURN
  151. 3140 FILE.EXISTS=TRUE
  152. 3150 ON ERROR GOTO 3600:OPEN"I",1,BF$
  153. 3160 ON ERROR GOTO 0: CLOSE:IF NOT FILE.EXISTS THEN 3000
  154. 3170 BX=20:BY=175:GOSUB 7500:HF$=RET$
  155. 3180 OPEN"O",2,HF$
  156. 3190 F$=BF$:GOSUB 4580:GOSUB 4000:LF=LFD+LFR
  157. 3200 CLS:CALL TEXTFACE(0)
  158. 3210 PRINT "LENGTH of Application document is:";LF;" bytes (characters)"
  159. 3220 PRINT "TYPE of Application document is: ";LEFT$(TYPEAPPL$,4)
  160. 3230 PRINT "CREATOR of Application document is: ";RIGHT$(TYPEAPPL$,4)
  161. 3235 PRINT "DOCUMENT is a ";:IF LFD=0 THEN PRINT "Resource File":ELSE PRINT "Data File"
  162. 3240 PRINT:CALL TEXTFONT(4):CALL TEXTSIZE(9)
  163. 3250 PRINT "<---Hex data being output-------------------------------------->  ";
  164. 3260 PRINT"Processed/Total"
  165. 3270 CKSUM%=0:COUNT=0
  166. 3275 IF LFD=0 THEN GOSUB 22000:GOTO 3380
  167. 3280 PRINT #2,"#";TYPEAPPL$:PRINT #2,"***DATA FORK"
  168. 3285 OPEN "R",1,BF$,1:FIELD 1,1 AS D$
  169. 3290 FOR I = 1 TO LFD
  170. 3300            GET 1,I
  171. 3310            DD$=HEX$(ASC(D$)):IF LEN(DD$)<2 THEN DD$="0"+DD$
  172. 3320            CKSUM%=(CKSUM%+ASC(D$)) AND 255
  173. 3330            PRINT #2,DD$;:PRINT DD$;
  174. 3340            COUNT=COUNT+1
  175. 3350            IF COUNT=32 THEN COUNT=0:PRINT #2,"":PRINT USING " ######_/";I;:PRINT LFD
  176. 3360 NEXT I
  177. 3370 IF COUNT<32 THEN PRINT #2,""
  178. 3380 PRINT #2,"***END OF DATA"
  179. 3390 XX$=HEX$(CKSUM%):IF LEN(XX$)<2 THEN XX$="0"+XX$
  180. 3400 PRINT #2,"***CHECKSUM:";XX$
  181. 3410 CLOSE:CALL TEXTFONT(0):CALL TEXTSIZE(12)
  182. 3420 RECT%(0)=30:RECT%(1)=80:RECT%(2)=220:RECT%(3)=410:GOSUB 7100
  183. 3430 RECT%(0)=33:RECT%(1)=83:RECT%(2)=217:RECT%(3)=407:GOSUB 7200
  184. 3440 CALL MOVETO(90,70):CALL TEXTMODE(1)
  185. 3450 PRINT "Conversion of Application document to an";
  186. 3460 CALL MOVETO (90,85)
  187. 3470 PRINT "Upload format document has been completed!";
  188. 3480 BEEP:RESTORE 3510:GOSUB 6000
  189. 3490 WEND: '  of the WHILE CHOICE=1
  190. 3500 RETURN: ' if CHOICE=2
  191. 3510 DATA 110,120,"Convert another Application document"
  192. 3520 DATA 110,160,"Return to Main Conversion Menu"
  193. 3530 DATA -1,-1,"dummy end of list"
  194. 3540 '------ Subroutine to handle file-not-found condition ------
  195. 3600 RECT%(0)=75:RECT%(1)=100:RECT%(2)=165:RECT%(3)=400:GOSUB 7100
  196. 3610 RECT%(0)=79:RECT%(1)=103:RECT%(2)=162:RECT%(3)=397:GOSUB 7200
  197. 3620 CALL MOVETO(160,110):PRINT"That document does not exist!";
  198. 3630 BEEP:BEEP:RESTORE 3640:GOSUB 6000
  199. 3640 DATA 150,130,"<--Click here to select another file"
  200. 3650 DATA -1,-1,"Dummy end of File not found list"
  201. 3660 FILE.EXISTS=FALSE:RESUME NEXT
  202. 3670 '------------------------------------------------------------
  203. 3680 '   _GetFileInfo --  Subroutine to get type and application of a file
  204. 3690 '------------------------------------------------------------
  205. 4000 FL=LEN(F$)
  206. 4010 F$=CHR$(FL)+F$
  207. 4020 FP!=VARPTR(F$)
  208. 4030 PARAM!=VARPTR(PARAMLIST%(0))
  209. 4040 FOR I=0 TO 79: POKE PARAM!+I,0: NEXT I
  210. 4050 POKE PARAM!+19,PEEK(FP!+2)
  211. 4060 POKE PARAM!+20,PEEK(FP!+3)
  212. 4070 POKE PARAM!+21,PEEK(FP!+4)
  213. 4080 GETFILEINFO!=VARPTR(GETFILEINFOCODE%(0))
  214. 4090 CALL GETFILEINFO!(PARAM!)
  215. 4100 TYPEAPPL$ = ""
  216. 4110 FOR I = 1 TO 8
  217. 4120 TYPEAPPL$ = TYPEAPPL$ + CHR$(PEEK(PARAM!+31+I))
  218. 4130 NEXT I
  219. 4135 LFD=PEEK(PARAM!+56)*256+PEEK(PARAM!+57)
  220. 4136 LFR=PEEK(PARAM!+66)*256+PEEK(PARAM!+67)
  221. 4140 RETURN
  222. 4150 '-------------------------------------------------------------
  223. 4160 '   _SetFileInfo  --  Subroutine to set type and application of a file
  224. 4170 '-------------------------------------------------------------
  225. 4200 FL=LEN(F$)
  226. 4210 F$=CHR$(FL)+F$
  227. 4220 PARAM!=VARPTR(PARAMLIST%(0))
  228. 4230 FP!=VARPTR(F$)
  229. 4240 FOR I=0 TO 79: POKE PARAM!+I,0: NEXT I
  230. 4250 POKE PARAM!+19,PEEK(FP!+2)
  231. 4260 POKE PARAM!+20,PEEK(FP!+3)
  232. 4270 POKE PARAM!+21,PEEK(FP!+4)
  233. 4280 GETFILEINFO!=VARPTR(GETFILEINFOCODE%(0))
  234. 4290 CALL GETFILEINFO!(PARAM!)
  235. 4300 FOR I=1 TO LEN(TYPEAPPL$)
  236. 4310 POKE PARAM!+31+I,ASC(MID$(TYPEAPPL$,I,1))
  237. 4320 NEXT I
  238. 4330 SETFILEINFO!=VARPTR(SETFILEINFOCODE%(0))
  239. 4340 CALL SETFILEINFO!(PARAM!)
  240. 4350 RETURN
  241. 4360 '-----------------------------------------------------------
  242. 4370 '                Setup Machine Language Toolkit calls
  243. 4380 '-----------------------------------------------------------
  244. 4560 '               Set up  _GetFileInfo  ToolKit call
  245. 4580 RESTORE 4610:I=0
  246. 4590 READ A:GETFILEINFOCODE%(I)=A
  247. 4600 I=I+1:IF A<>-1 THEN GOTO 4590
  248. 4605 RETURN
  249. 4610 DATA &H4E56, &HFFF8, &H48EE, &H0101, &HFFF8, &H206E, &H0008, &HA00C
  250. 4620 DATA &H4CEE, &H0101, &HFFF8, &H4E5E, &H4E75
  251. 4630 DATA -1
  252. 4640 '               Set up _SetFileInfo Toolkit call
  253. 4660 RESTORE 4700:I=0
  254. 4670 READ A:SETFILEINFOCODE%(I)=A
  255. 4680 I=I+1:IF A<>-1 THEN GOTO 4670
  256. 4690 RETURN
  257. 4700 DATA &H4E56, &HFFF8, &H48EE, &H0101, &HFFF8, &H206E, &H0008, &HA00D
  258. 4710 DATA &H4CEE, &H0101, &HFFF8, &H4E5E, &H4E75
  259. 4720 DATA -1
  260. 4730 '----------------------------------------------------------
  261. 4740 '                   Pseudo-Dialog-Box subroutine
  262. 4750 '----------------------------------------------------------
  263. 6000 BOX=0:READ X,Y,TEXT$
  264. 6010 WHILE X<>-1
  265. 6020    BOX=BOX+1:CHECKBOX(BOX,1)=X:CHECKBOX(BOX,2)=Y
  266. 6030    CHECKTEXT$(BOX)=TEXT$:READ X,Y,TEXT$
  267. 6040 WEND
  268. 6050 FOR I=1 TO BOX
  269. 6060    CIRCLE(CHECKBOX(I,1),CHECKBOX(I,2)),7
  270. 6070    CIRCLE(CHECKBOX(I,1),CHECKBOX(I,2)),5
  271. 6080    CALL MOVETO(CHECKBOX(I,1)+15,CHECKBOX(I,2)+5)
  272. 6090    PRINT CHECKTEXT$(I);
  273. 6100 NEXT I
  274. 6110 CHOICE=0
  275. 6120 WHILE CHOICE=0
  276. 6130    WHILE MOUSE(0)<>-1:WEND
  277. 6140    PX=MOUSE(1):PY=MOUSE(2)
  278. 6150    FOR I=1 TO BOX
  279. 6160            P=SQR((PX-CHECKBOX(I,1))^2+(PY-CHECKBOX(I,2))^2)
  280. 6170            IF P<5 THEN CHOICE=I:I=BOX :' once choice found, stop loop.
  281. 6180    NEXT I
  282. 6190 WEND
  283. 6200  FOR I=0 TO 4
  284. 6210    CIRCLE(CHECKBOX(CHOICE,1),CHECKBOX(CHOICE,2)),I
  285. 6220 NEXT I
  286. 6230 WHILE MOUSE(0)<>1:WEND:RETURN
  287. 6240 '---------------------------------------------------
  288. 6250 '                Routines used to draw Dialog boxes
  289. 6260 '---------------------------------------------------
  290. 7000 CALL ERASERECT(VARPTR(RECT%(0)))
  291. 7010 CALL FRAMERECT(VARPTR(RECT%(0)))
  292. 7020 RETURN
  293. 7100 CALL PENNORMAL:GOSUB 7000:RETURN
  294. 7200 CALL PENSIZE(2,2):GOSUB 7000:CALL PENNORMAL:RETURN
  295. 7210 '---------------------------------------------------------
  296. 7220 '     Controlled Keyboard input routine, with cursor
  297. 7230 '---------------------------------------------------------
  298. 7500 A$="":RET$=""
  299. 7510 CALL MOVETO(BX,BY):CALL TEXTMODE(0)
  300. 7520 CALL PENSIZE(1,1):CALL SHOWPEN
  301. 7530 CALL OBSCURECURSOR:CALL LINE(0,-10)
  302. 7540 WHILE A$<>CHR$(13) AND A$<> CHR$(9) AND A$<>CHR$(3)
  303. 7550    A$=INKEY$
  304. 7560    IF A$<>"" AND A$>CHR$(31) THEN GOSUB 7630
  305. 7570    IF A$=CHR$(8) AND LEN(RET$)>0 THEN GOSUB 7660
  306. 7580    IF A$=CHR$(8) AND LEN(RET$)=0 THEN GOSUB 7690
  307. 7590    IF LEN(RET$)>65 THEN BEEP:A$=CHR$(13)
  308. 7600 WEND
  309. 7610 CALL MOVETO(BX,BY):PRINT RET$;" ";:RETURN
  310. 7620 '-------- Handle normal input of letter ASCII 32-255 ------------
  311. 7630 RET$=RET$+A$:CALL LINE(0,10)
  312. 7640 PRINT A$;:CALL LINE(0,-10):RETURN
  313. 7650 '------- Hande Backspacing with input length >0 ----------------
  314. 7660 CALL MOVETO(BX,BY):RET$=LEFT$(RET$,LEN(RET$)-1)
  315. 7670 PRINT RET$;:CALL LINE(0,-10):RETURN
  316. 7680 '------- Handle Backspacing when input length goes to 0 ------
  317. 7690 CALL MOVETO(BX,BY):PRINT"   ";:CALL LINE(0,-10):
  318. 7700 CALL MOVETO (BX,BY):CALL LINE(0,-10):RETURN
  319. 7710 '------- Change Window Background pattern to grey -------
  320. 8000 FOR I=0 TO 4:BACKPATTERN%(I)=&HAA55:NEXT I
  321. 8010 CALL BACKPAT(VARPTR(BACKPATTERN%(0))):CLS
  322. 8020 FOR I=0 TO 4:BACKPATTERN%(I)=0:NEXT I
  323. 8030 CALL BACKPAT(VARPTR(BACKPATTERN%(0))):RETURN
  324. 10000 ' Open Resource Fork For E$
  325. 10010 IF P(0)<>&H41FA THEN GOSUB 15000
  326. 10020 P(8)=&HA20A:' Open RF
  327. 10030 Y=VARPTR(P(42)):'length of file name
  328. 10040 POKE Y,LEN(E$)
  329. 10050 FOR I=1 TO LEN(E$):POKE (Y+I),ASC(MID$(E$,I,1)):NEXT I
  330. 10060 P(25)=INT(Y/65536!):GOSUB 20000
  331. 10070 P(26)=X:'lsw of name
  332. 10080 P(27)=0:'volume
  333. 10090 P(29)=RW:'version and R/W Permission
  334. 10100 P(30)=0'Nil-> default volume buffer msw
  335. 10110 P(31)=0:'Nil-> default volume buffer lsw
  336. 10115 IF RW=1 THEN GOTO 10160
  337. 10120 Y=VARPTR(VBUF%(0))
  338. 10130 P(30)=INT(Y/65536!):GOSUB 20000:' volume buffer msw
  339. 10140 P(31)=X:'volume buffer lsw
  340. 10160 X=VARPTR(P(0)):CALL X:'open the Fork
  341. 10170 RC=P(16):'return code
  342. 10180 RFN=P(28):'reference number
  343. 10190 RETURN
  344. 10500 ' Close RF at RefNum
  345. 10510 IF P(0)<>&H41FA THEN GOSUB 15000
  346. 10520 P(8)=&HA201:'Close RF byte
  347. 10530 P(28)=RFN:'Refnum
  348. 10540 GOTO 10030 :'insert into main loop
  349. 11000 'Set up for Write RF
  350. 11010 IF P(0)<>&H41FA THEN GOSUB 15000
  351. 11020 P(8)=&HA203:'Write byte
  352. 11030 P(39)=0:' offset msw
  353. 11033 Y=VARPTR(VBUF%(0)):P(30)=INT(Y/65536!):GOSUB 20000
  354. 11036 P(31)=X
  355. 11040 P(40)=0:'offset lsw
  356. 11050 TR=VARPTR(DBUF%(0))
  357. 11060 P(32)=INT(TR/65535!):Y=TR:GOSUB 20000
  358. 11080 P(33)=X:'buffer
  359. 11090 P(34)=0:'count high
  360. 11100 P(35)=1:'count low
  361. 11110 P(38)=1:'mode as absolute offset
  362. 11120 RETURN
  363. 12000 'Write RF (hex->bin)
  364. 12010 IF EOF (1) THEN GOTO 12990:' return
  365. 12020 E=0: IF EOF(1) THEN CLS:PRINT "Hex File Error":GOTO 12990
  366. 12030 INPUT #1,D$
  367. 12040 IF MID$(D$,1,6)="***END" THEN 12100
  368. 12050 FOR I=1 TO LEN (D$) STEP 2
  369. 12060     X=VAL("&H"+MID$(D$,I,2)):CKSUM%=(CKSUM%+X) AND X255%
  370. 12070      GOSUB 13000:E=E+1:'write byte at offset E
  371. 12080 NEXT I
  372. 12085 CALL MOVETO(190,158):PRINT USING "####.##_K";(E/1024)
  373. 12090 GOTO 12030
  374. 12100 INPUT #1,D$:'get the checksum
  375. 12990 CLOSE:RETURN
  376. 13000 'Write Byte X at offset E
  377. 13010 POKE VARPTR(DBUF%(0)),X
  378. 13015 P(39)=INT(E/65536!):Y=E:GOSUB 20000:' offset msw
  379. 13020 P(40)=X:'offset lsw
  380. 13030 X=VARPTR (P(0)):CALL X:' write it!
  381. 13040 RC=P(16):'return code
  382. 13050 IF RC<>0 THEN CLS: PRINT "Write RF Error":GOSUB 14000:CLOSE:END
  383. 13060 RETURN
  384. 14000 'Close RF 
  385. 14010 GOSUB 10500:'Closing Header to RF routine
  386. 14020 IF RC=0 THEN RETURN
  387. 14030 PRINT "File Error on Closing RF"
  388. 14040 GOTO 14100
  389. 14050 'Open RF for E$
  390. 14060 RW=1:'set to read
  391. 14070 GOSUB 10000:'Open RF
  392. 14080 IF RC=0 THEN RETURN
  393. 14090 CLS:PRINT "FILE ERROR ON OPENING RF"
  394. 14100 PRINT "Return Code = ";RC
  395. 14110 CLOSE :END
  396. 15000 'Load Code Array
  397. 15010 I=0
  398. 15020 RESTORE 15500
  399. 15030 READ X:IF X<>-5 THEN P(I)=X:I=I+1:GOTO 15030
  400. 15040 RETURN
  401. 15500 DATA &H41FA,&H001E,&H2278,&H011C
  402. 15510 DATA &H2269,&H0010,&H2251,&H4280,&HA40A
  403. 15520 DATA &H41FA,&H000A,&H3080,&H4E75,&H7268,&H6E00,0
  404. 15530 DATA &H0000,&H0000,&H0005,&H0000
  405. 15540 DATA &H0000,&H0000,&H0000,&H0000
  406. 15550 DATA &H0001,&H0000,&H0000,&H0000
  407. 15560 DATA &HFFFE,&H0000,&H0000,&H0000
  408. 15570 DATA &H0001,&H3000,&H0000,&H0200
  409. 15580 DATA &H0000,&H0000,&H0001,&H0000,&H0000
  410. 15590 DATA-5
  411. 16000 'REad RF at E
  412. 16010 IF P(0)<>&H41FA THEN GOSUB 15000
  413. 16020 P(8)=&HA202:'Read byte
  414. 16030 P(39)=INT(E/65536!):Y=E:GOSUB 20000:'offset msw
  415. 16040 P(40)=X: 'offset lsw
  416. 16050 TR=VARPTR(DBUF%(0))
  417. 16060 P(32)=INT(TR/65536!):Y=TR:GOSUB 20000:'buffer msw
  418. 16070 P(33)=X:'buffer lsw
  419. 16080 P(34)=0:'count high
  420. 16090 P(35)=RN:'count low
  421. 16100 P(38)=1:'mode is absolute offset
  422. 16110 X=VARPTR(P(0)):CALL X:'read it!
  423. 16120 RC= P(16):'return code
  424. 16130 RX=P(37):'returned count
  425. 16140 IF RC<>0 THEN CLS:PRINT "Read RF Error":GOSUB 14000:CLOSE:END
  426. 16150 RETURN
  427. 18000 'Dump the RF
  428. 18010 E=0:CKSUM%=0:S=0
  429. 18020 IF E>=LFR-1 THEN RN=0: GOTO 18140: ELSE RN=256:IF LFR-E<=256 THEN RN=LFR-E
  430. 18030 GOSUB 16000:'get the buffer filled with RF
  431. 18040 FOR I=0 TO RX-1
  432. 18050      X9=(PEEK(VARPTR(DBUF%(0))+I))
  433. 18060      HX$=HEX$(X9):IF LEN(HX$)<2 THEN HX$="0"+HX$
  434. 18070      CKSUM%=(CKSUM%+X9) AND X255% 
  435. 18080      PRINT HX$;: PRINT #2,HX$;
  436. 18090      S=S+1:IF S>31 THEN S=0:PRINT USING " ######_/";(E+I+1);:PRINT LFR:PRINT #2,""
  437. 18120 NEXT I
  438. 18140 IF S>0 THEN PRINT #2,""
  439. 18150 IF RN<256 THEN RETURN
  440. 18160 E=E+256:GOTO 18020
  441. 18170 END
  442. 20000 X=Y-65536!*INT(Y/65536!):IF X>=32768! THEN X=X-65536!
  443. 20010 RETURN
  444. 21000 'Resource hex->bin Subroutine
  445. 21010 CLOSE #2:E$=BF$:RW=2:GOSUB 14070:'Open RF to write
  446. 21020 GOSUB 11000:'Setup To Write to RF
  447. 21030 GOSUB 12000:'Dump the Hex->RF
  448. 21040 GOSUB 14000:'Close rf
  449. 21050 RETURN
  450. 22000 'Resource Bin-> hex subroutine
  451. 22010 PRINT #2,"#";TYPEAPPL$:PRINT #2,"***RESOURCE FORK"
  452. 22020 E$=BF$:RW=1
  453. 22030 GOSUB 14070:'Open RF
  454. 22040 GOSUB 18000:'Dump Fork
  455. 22050 GOSUB 14000:'Close Fork
  456. 22060 RETURN
  457. URCE FORK"
  458. 22020 E$=BF$:RW=1
  459. 22030 GOSUB 14070:'Open RF
  460. 22040 GOSUB 18000:'Dump Fork
  461. 22050 GOSUB 14000:'Clos